home *** CD-ROM | disk | FTP | other *** search
/ Super Shareware Collection / Super Shareware Collection.iso / os_2 / clisp.zip / USER1.LSP < prev    next >
Encoding:
Text File  |  1994-02-05  |  29.1 KB  |  760 lines
  1. ;;;; User-Interface, Teil 1
  2. ;;;; Eval-Env, Debugger, Stepper, Errors, Query-User
  3. ;;;; Bruno Haible 4.2.1990, 4.11.1991
  4.  
  5. (in-package "LISP")
  6. (export '(the-environment eval-env with-keyboard *keyboard-input*))
  7. (in-package "SYSTEM")
  8.  
  9. ;-------------------------------------------------------------------------------
  10. ;;                       THE-ENVIRONMENT und EVAL-ENV
  11.  
  12. ; THE-ENVIRONMENT wie in SCHEME
  13. (defvar *COMPILING* nil)
  14. (defun %the-environment (form env)
  15.   (declare (ignore form))
  16.   (setf (svref env 0) (svref (svref env 0) 2)) ; *evalhook*-Bindung streichen
  17.   env
  18. )
  19. (defmacro the-environment ()
  20.   (if *COMPILING*
  21.     (error #+DEUTSCH "~S ist in compiliertem Code unmöglich."
  22.            #+ENGLISH "~S is impossible in compiled code"
  23.            #+FRANCAIS "~S est impossible dans du code compilé."
  24.            'the-environment
  25.     )
  26.     `(let ((*evalhook* #'%the-environment)) 0)
  27. ) )
  28.  
  29. ; Das Toplevel-Environment
  30. (defparameter *toplevel-environment* (eval '(the-environment)))
  31. (defparameter *toplevel-denv* (svref *toplevel-environment* 4))
  32.  
  33. ; Evaluiert eine Form in einem Environment
  34. (defun eval-env (form &optional (env *toplevel-environment*))
  35.   (evalhook form nil nil env)
  36. )
  37.  
  38. ;-------------------------------------------------------------------------------
  39. ;;                                 Debugger
  40.  
  41. (defvar *break-count* 0) ; Anzahl der aktiven Break-Schleifen (Fixnum >=0)
  42.  
  43. ; Hauptschleife:
  44. ; (driver
  45. ;   #'(lambda () (read-eval-print "> "))
  46. ; )
  47.  
  48. ; Help-Funktion:
  49. (defvar *key-bindings* nil) ; Liste von Tasten-Bindungen und Helpstrings
  50. (defun help ()
  51.   (dolist (s (reverse (remove-if-not #'stringp *key-bindings*)))
  52.     (write-string s #|*debug-io*|#)
  53. ) )
  54.  
  55. ; Bausteine der Break-Schleife:
  56. (defvar *debug-frame*)
  57. (defvar *debug-mode*)
  58. (defvar *frame-limit1* nil) ; untere Grenze für frame-down und frame-down-1
  59. (defvar *frame-limit2* nil) ; obere Grenze für frame-up und frame-up-1
  60. (defun frame-limit1 (frames-to-skip)
  61.   (let ((frame (the-frame)))
  62.     (let ((*frame-limit1* nil)
  63.           (*frame-limit2* nil))
  64.       (dotimes (i frames-to-skip) (setq frame (frame-up-1 frame 1)))
  65.     )
  66.     frame
  67. ) )
  68. (defun frame-limit2 ()
  69.   (let ((frame (the-frame)))
  70.     (let ((*frame-limit1* nil)
  71.           (*frame-limit2* nil))
  72.       (loop
  73.         (let ((nextframe (frame-up-1 frame 1)))
  74.           (when (or (eq nextframe frame) (driver-frame-p nextframe)) (return))
  75.           (setq frame nextframe)
  76.       ) )
  77.       (dotimes (i 2) (setq frame (frame-down-1 frame 1)))
  78.     )
  79.     frame
  80. ) )
  81. (defun debug-help () (help) (throw 'debug 'continue))
  82. (defun debug-unwind () (throw 'debug 'unwind))
  83. (defun debug-mode-1 () (setq *debug-mode* 1) (throw 'debug 'continue))
  84. (defun debug-mode-2 () (setq *debug-mode* 2) (throw 'debug 'continue))
  85. (defun debug-mode-3 () (setq *debug-mode* 3) (throw 'debug 'continue))
  86. (defun debug-mode-4 () (setq *debug-mode* 4) (throw 'debug 'continue))
  87. (defun debug-mode-5 () (setq *debug-mode* 5) (throw 'debug 'continue))
  88. (defun debug-where ()
  89.   (describe-frame *standard-output* *debug-frame*)
  90.   (throw 'debug 'continue)
  91. )
  92. (defun debug-up ()
  93.   (describe-frame *standard-output*
  94.     (setq *debug-frame* (frame-up-1 *debug-frame* *debug-mode*))
  95.   )
  96.   (throw 'debug 'continue)
  97. )
  98. (defun debug-top ()
  99.   (describe-frame *standard-output*
  100.     (setq *debug-frame* (frame-up *debug-frame* *debug-mode*))
  101.   )
  102.   (throw 'debug 'continue)
  103. )
  104. (defun debug-down ()
  105.   (describe-frame *standard-output*
  106.     (setq *debug-frame* (frame-down-1 *debug-frame* *debug-mode*))
  107.   )
  108.   (throw 'debug 'continue)
  109. )
  110. (defun debug-bottom ()
  111.   (describe-frame *standard-output*
  112.     (setq *debug-frame* (frame-down *debug-frame* *debug-mode*))
  113.   )
  114.   (throw 'debug 'continue)
  115. )
  116. (defun debug-backtrace (&optional (mode *debug-mode*))
  117.   (let ((frame (frame-down-1 (frame-up-1 *frame-limit1* mode) mode)))
  118.     (loop
  119.       (describe-frame *standard-output* frame)
  120.       (when (eq frame (setq frame (frame-up-1 frame mode))) (return))
  121.   ) )
  122.   (throw 'debug 'continue)
  123. )
  124. (defun debug-backtrace-1 () (debug-backtrace 1))
  125. (defun debug-backtrace-2 () (debug-backtrace 2))
  126. (defun debug-backtrace-3 () (debug-backtrace 3))
  127. (defun debug-backtrace-4 () (debug-backtrace 4))
  128. (defun debug-backtrace-5 () (debug-backtrace 5))
  129. (defun debug-redo ()
  130.   (redo-eval-frame *debug-frame*)
  131.   (throw 'debug 'continue)
  132. )
  133. (defun debug-return ()
  134.   (return-from-eval-frame *debug-frame*
  135.     (read-form #+DEUTSCH "Werte: "
  136.                #+ENGLISH "values: "
  137.                #+FRANCAIS "Valeurs : "
  138.   ) )
  139.   (throw 'debug 'continue)
  140. )
  141. (defun debug-continue () (throw 'debug 'quit))
  142.  
  143. #+ATARI (progn
  144. (defconstant commands0
  145.              (list
  146.                #+DEUTSCH "
  147. Help        = diese Sondertasten-Liste
  148. Backspace     ein Zeichen nach links löschen
  149. Delete        ein Zeichen nach rechts löschen
  150. Insert        eine Leerstelle einfügen
  151.              Cursor ein Zeichen nach links
  152.              Cursor ein Zeichen nach rechts
  153. Shift-       Cursor an den Zeilenanfang
  154. Shift-       Cursor ans Zeilenende
  155. Return, Enter beendet das Editieren dieser Zeile"
  156.                #+ENGLISH "
  157. Help        = this key list
  158. Backspace     deletes one character to the left
  159. Delete        deletes one character to the right
  160. Insert        inserts a space
  161.              moves the cursor one character to the left
  162.              moves the cursor one character to the right
  163. Shift-       moves the cursor to the beginning of the line
  164. Shift-       moves the cursor to the end of the line
  165. Return, Enter finishes editing of this line"
  166.                #+FRANCAIS "
  167. Help        = cette liste de touches spéciales
  168. Backspace     effacer un caractère vers la gauche
  169. Delete        effacer un caractère vers la droite
  170. Insert        ajouter un espace
  171.              Cursor vers la gauche
  172.              Cursor vers la droite
  173. Shift-       Cursor au début de la ligne
  174. Shift-       Cursor à la fin de la ligne
  175. Return, Enter finit les changements de cette ligne"
  176.                (cons #\Help   #'debug-help  )
  177. )            )
  178. (defconstant commands1
  179.              (list
  180.                #+DEUTSCH "
  181. Help   = dieses Menü
  182. Undo   = Abbruch, Rücksprung zur nächsthöheren Eingabeschleife
  183. F1     = alle Stack-Elemente inspizieren
  184. F2     = alle Frames inspizieren
  185. F3     = nur EVAL- und APPLY-Frames inspizieren (Default)
  186. F4     = nur APPLY-Frames inspizieren
  187. .      = diesen Frame inspizieren
  188.       = nächsthöheren Frame inspizieren
  189. Shift = obersten Frame inspizieren
  190.       = nächstneueren Frame inspizieren
  191. Shift = neuesten Frame inspizieren
  192. ShiftF1= alle Stack-Elemente auflisten
  193. ShiftF2= alle Frames auflisten
  194. ShiftF3= alle EVAL- und APPLY-Frames auflisten
  195. ShiftF4= alle APPLY-Frames auflisten
  196. F5     = Redo: Form im EVAL-Frame erneut auswerten
  197. F6     = Return: EVAL-Frame mit gegebenen Werten verlassen"
  198.                #+ENGLISH "
  199. Help   = this command list
  200. Undo   = abort to the next recent input loop
  201. F1     = inspect all the stack elements
  202. F2     = inspect all the frames
  203. F3     = inspect only EVAL and APPLY frames (default)
  204. F4     = inspect only APPLY frames
  205. .      = inspect this frame
  206.       = go up one frame, inspect it
  207. Shift = go to top frame, inspect it
  208.       = go down one frame, inspect it
  209. Shift = go to bottom (most recent) frame, inspect it
  210. ShiftF1= list all stack elements
  211. ShiftF2= list all frames
  212. ShiftF3= list all EVAL and APPLY frames
  213. ShiftF4= list all APPLY frames
  214. F5     = redo: re-evaluate form in EVAL frame
  215. F6     = return: leave EVAL frame, prescribing the return values"
  216.                #+FRANCAIS "
  217. Help   = ce menu-ci
  218. Undo   = arrêt, retour au niveau supérieur
  219. F1     = examiner tous les éléments de la pile
  220. F2     = examiner tous les «frames»
  221. F3     = examiner uniquement les «frames» EVAL et APPLY (par défaut)
  222. F4     = examiner uniquement les «frames» APPLY
  223. .      = examiner ce «frame»
  224.       = examiner un «frame» supérieur
  225. Shift = examiner le «frame» le plus élevé
  226.       = examiner un prochain «frame» plus récent (inférieur)
  227. Shift = examiner le «frame» le plus récent (le plus bas)
  228. ShiftF1= montrer tous les éléments de la pile
  229. ShiftF2= montrer tous les «frames»
  230. ShiftF3= montrer tous les «frames» EVAL et APPLY
  231. ShiftF4= montrer tous les «frames» APPLY
  232. F5     = Redo: réévaluer la forme dans le «frame» EVAL
  233. F6     = Return: quitter le «frame» EVAL avec certaines valeurs"
  234.                (cons #\Help   #'debug-help  )
  235.                (cons #\?      #'debug-help  )
  236.                (cons #\Undo   #'debug-unwind)
  237.                (cons #\F1     #'debug-mode-1)
  238.                (cons #\F2     #'debug-mode-2)
  239.                (cons #\F3     #'debug-mode-4)
  240.                (cons #\F4     #'debug-mode-5)
  241.                (cons #\.      #'debug-where )
  242.                (cons #\Up     #'debug-up    )
  243.                (cons #\S-Up   #'debug-top   )
  244.                (cons #\Down   #'debug-down  )
  245.                (cons #\S-Down #'debug-bottom)
  246.                (cons #\S-F1   #'debug-backtrace-1)
  247.                (cons #\S-F2   #'debug-backtrace-2)
  248.                (cons #\S-F3   #'debug-backtrace-4)
  249.                (cons #\S-F4   #'debug-backtrace-5)
  250. )            )
  251. (defconstant commands2
  252.              (list
  253.                (cons #\F5     #'debug-redo  )
  254.                (cons #\F6     #'debug-return)
  255. )            )
  256. (defconstant commands3
  257.              (list
  258.                #+DEUTSCH "
  259. F10    = Continue: Rest weiter abarbeiten"
  260.                #+ENGLISH "
  261. F10    = continue: continue evaluation"
  262.                #+FRANCAIS "
  263. F10    = Continue: continuer l'évaluation"
  264.                (cons #\F10  #'debug-continue)
  265. )            )
  266. )
  267. #-ATARI (progn
  268. (defconstant commands0
  269.              (list
  270.                #+DEUTSCH "
  271. Help = diese Liste
  272. Benutzen Sie die üblichen Editiermöglichkeiten."
  273.                #+ENGLISH "
  274. Help = this list
  275. Use the usual editing capabilities."
  276.                #+FRANCAIS "
  277. Help = cette liste
  278. Éditez de la façon habituelle."
  279.                (cons "Help"   #'debug-help  )
  280. )            )
  281. (defconstant commands1
  282.              (list
  283.                #+DEUTSCH "
  284. Help   = dieses Menü
  285. Abort  = Abbruch, Rücksprung zur nächsthöheren Eingabeschleife
  286. Unwind = Abbruch, Rücksprung zur nächsthöheren Eingabeschleife
  287. Mode-1 = alle Stack-Elemente inspizieren
  288. Mode-2 = alle Frames inspizieren
  289. Mode-3 = nur lexikalische Frames inspizieren
  290. Mode-4 = nur EVAL- und APPLY-Frames inspizieren (Default)
  291. Mode-5 = nur APPLY-Frames inspizieren
  292. Where  = diesen Frame inspizieren
  293. Up     = nächsthöheren Frame inspizieren
  294. Top    = obersten Frame inspizieren
  295. Down   = nächstneueren Frame inspizieren
  296. Bottom = neuesten Frame inspizieren
  297. Backtrace-1 = alle Stack-Elemente auflisten
  298. Backtrace-2 = alle Frames auflisten
  299. Backtrace-3 = alle lexikalische Frames auflisten
  300. Backtrace-4 = alle EVAL- und APPLY-Frames auflisten
  301. Backtrace-5 = alle APPLY-Frames auflisten
  302. Backtrace   = Stack auflisten im aktuellen Mode
  303. Redo   = Form im EVAL-Frame erneut auswerten
  304. Return = EVAL-Frame mit gegebenen Werten verlassen"
  305.                #+ENGLISH "
  306. Help   = this command list
  307. Abort  = abort to the next recent input loop
  308. Unwind = abort to the next recent input loop
  309. Mode-1 = inspect all the stack elements
  310. Mode-2 = inspect all the frames
  311. Mode-3 = inspect only lexical frames
  312. Mode-4 = inspect only EVAL and APPLY frames (default)
  313. Mode-5 = inspect only APPLY frames
  314. Where  = inspect this frame
  315. Up     = go up one frame, inspect it
  316. Top    = go to top frame, inspect it
  317. Down   = go down one frame, inspect it
  318. Bottom = go to bottom (most recent) frame, inspect it
  319. Backtrace-1 = list all stack elements
  320. Backtrace-2 = list all frames
  321. Backtrace-3 = list all lexical frames
  322. Backtrace-4 = list all EVAL and APPLY frames
  323. Backtrace-5 = list all APPLY frames
  324. Backtrace   = list stack in current mode
  325. Redo   = re-evaluate form in EVAL-Frame
  326. Return = leave EVAL-Frame, prescribing the return values"
  327.                #+FRANCAIS "
  328. Help   = ce menu-ci
  329. Abort  = arrêt, retour au niveau supérieur
  330. Unwind = arrêt, retour au niveau supérieur
  331. Mode-1 = examiner tous les éléments de la pile
  332. Mode-2 = examiner tous les «frames»
  333. Mode-3 = examiner uniquement les «frames» lexicaux
  334. Mode-4 = examiner uniquement les «frames» EVAL et APPLY (par défaut)
  335. Mode-5 = examiner uniquement les «frames» APPLY
  336. Where  = examiner ce «frame»
  337. Up     = examiner un «frame» supérieur
  338. Top    = examiner le «frame» le plus élevé
  339. Down   = examiner un prochain «frame» plus récent (inférieur)
  340. Bottom = examiner le «frame» le plus récent (le plus bas)
  341. Backtrace-1 = montrer tous les éléments de la pile
  342. Backtrace-2 = montrer tous les «frames»
  343. Backtrace-3 = montrer tous les «frames» lexicaux
  344. Backtrace-4 = montrer tous les «frames» EVAL et APPLY
  345. Backtrace-5 = montrer tous les «frames» APPLY
  346. Backtrace   = montrer la pile en mode actuel
  347. Redo   = réévaluer la forme dans le «frame» EVAL
  348. Return = quitter le «frame» EVAL avec certaines valeurs"
  349.                (cons "Help"   #'debug-help  )
  350.                (cons "?"      #'debug-help  )
  351.                (cons "Abort"  #'debug-unwind)
  352.                (cons "Unwind" #'debug-unwind)
  353.                (cons "Mode-1" #'debug-mode-1)
  354.                (cons "Mode-2" #'debug-mode-2)
  355.                (cons "Mode-3" #'debug-mode-3)
  356.                (cons "Mode-4" #'debug-mode-4)
  357.                (cons "Mode-5" #'debug-mode-5)
  358.                (cons "Where"  #'debug-where )
  359.                (cons "Up"     #'debug-up    )
  360.                (cons "Top"    #'debug-top   )
  361.                (cons "Down"   #'debug-down  )
  362.                (cons "Bottom" #'debug-bottom)
  363.                (cons "Backtrace-1" #'debug-backtrace-1)
  364.                (cons "Backtrace-2" #'debug-backtrace-2)
  365.                (cons "Backtrace-3" #'debug-backtrace-3)
  366.                (cons "Backtrace-4" #'debug-backtrace-4)
  367.                (cons "Backtrace-5" #'debug-backtrace-5)
  368.                (cons "Backtrace"   #'debug-backtrace  )
  369. )            )
  370. (defconstant commands2
  371.              (list
  372.                (cons "Redo"   #'debug-redo  )
  373.                (cons "Return" #'debug-return)
  374. )            )
  375. (defconstant commands3
  376.              (list
  377.                #+DEUTSCH "
  378. Continue = Rest weiter abarbeiten"
  379.                #+ENGLISH "
  380. Continue = continue evaluation"
  381.                #+FRANCAIS "
  382. Continue = continuer l'évaluation"
  383.                (cons "Continue" #'debug-continue)
  384. )            )
  385. )
  386.  
  387. ;; um Help-Kommando erweiterte Hauptschleife.
  388. (defun main-loop ()
  389.   (setq *break-count* 0)
  390.   (driver ; Driver-Frame aufbauen und folgende Funktion (endlos) ausführen:
  391.     #'(lambda ()
  392.         (catch 'debug ; die (throw 'debug ...) abfangen
  393.           (if ; Eingabezeile verlangen
  394.               (read-eval-print "> " (copy-list commands0))
  395.             ; T -> #<EOF>
  396.             (exit)
  397.             ; NIL -> Form bereits ausgewertet und ausgegeben
  398. ) )   ) ) )
  399. (setq *driver* #'main-loop)
  400.  
  401. ;; komfortable Break-Schleife. (Läuft nur in compiliertem Zustand!)
  402. (defun break-loop (continuable)
  403.   (tagbody
  404.     (let* ((*break-count* (1+ *break-count*))
  405.            (stream (make-synonym-stream '*debug-io*))
  406.            (*standard-input* stream)
  407.            (*standard-output* stream)
  408.            (prompt (with-output-to-string (s)
  409.                       (write *break-count* :stream s)
  410.                       (write-string ". Break" s)
  411.                       (write-string "> " s)
  412.            )       )
  413.            (*frame-limit1* (frame-limit1 12))
  414.            (*frame-limit2* (frame-limit2))
  415.            (*debug-mode* 4)
  416.            (*debug-frame* (frame-down-1 (frame-up-1 *frame-limit1* *debug-mode*) *debug-mode*))
  417.           )
  418.       (driver ; Driver-Frame aufbauen und folgende Funktion (endlos) ausführen:
  419.         #'(lambda ()
  420.             (case
  421.                 (catch 'debug ; die (throw 'debug ...) abfangen und analysieren
  422.                   (same-env-as *debug-frame* ; bei *debug-frame* gültiges Environment aufbauen
  423.                     #'(lambda ()
  424.                         (if ; Eingabezeile verlangen
  425.                             (read-eval-print prompt
  426.                               (nconc (copy-list commands1)
  427.                                      (when (eval-frame-p *debug-frame*) (copy-list commands2))
  428.                                      (when continuable (copy-list commands3))
  429.                             ) )
  430.                           ; T -> #<EOF>
  431.                           #|(throw 'debug 'quit)|# (go quit)
  432.                           ; NIL -> Form bereits ausgewertet und ausgegeben
  433.                           #|(throw 'debug 'continue)|#
  434.                 ) )   ) )
  435.               (unwind (go unwind))
  436.               (quit (go quit)) ; nur erreicht, falls continuable
  437.               (t ) ; alles andere, insbesondere continue
  438.     ) )   ) )
  439.     unwind (unwind-to-driver)
  440.     quit
  441. ) )
  442. (setq *break-driver* #'break-loop)
  443.  
  444. ;-------------------------------------------------------------------------------
  445. ;;        komfortabler Stepper. (Läuft nur in compiliertem Zustand!)
  446.  
  447. (defvar *step-level* 0) ; momentane Step-Tiefe
  448. (defvar *step-quit* most-positive-fixnum) ; kritische Step-Tiefe:
  449.   ; sobald diese unterschritten wird, wacht der Stepper wieder auf.
  450. (defvar *step-watch* nil) ; Abbruchbedingung
  451.  
  452. ; (STEP form), CLTL S. 441
  453. (defmacro step (form)
  454.   `(let* ((*step-level* 0)
  455.           (*step-quit* most-positive-fixnum)
  456.           (*step-watch* nil)
  457.           (*evalhook* #'step-hook-fn))
  458.      ,form
  459.    )
  460. )
  461.  
  462. #+ATARI
  463. (defconstant commands4
  464.              (list
  465.                #+DEUTSCH "
  466. F7     = Step into form: diese Form im Einzelschrittmodus ausführen
  467. F8     = Step over form: diese Form auf einmal ausführen
  468. F9     = Step over this level: bis zum Aufrufer auf einmal ausführen
  469. F10    = Continue: Einzelschrittmodus abschalten, Rest ausführen
  470. Shift F7-F10: dito, jedoch mit Angabe einer Abbruchbedingung"
  471.                #+ENGLISH "
  472. F7     = step into form: evaluate this form in single step mode
  473. F8     = step over form: evaluate this form at once
  474. F9     = step over this level: evaluate at once up to the next return
  475. F10    = continue: switch off single step mode, continue evaluation
  476. Shift F7-F10: same as above, specify a condition when to stop"
  477.                (cons #\F7    #'(lambda () (throw 'stepper 'into)))
  478.                (cons #\F8    #'(lambda () (throw 'stepper 'over)))
  479.                (cons #\F9    #'(lambda () (throw 'stepper 'over-this-level)))
  480.                (cons #\F10   #'(lambda () (throw 'stepper 'continue)))
  481.                (cons #\S-F7  #'(lambda () (throw 'stepper (values 'into t))))
  482.                (cons #\S-F8  #'(lambda () (throw 'stepper (values 'over t))))
  483.                (cons #\S-F9  #'(lambda () (throw 'stepper (values 'over-this-level t))))
  484.                (cons #\S-F10 #'(lambda () (throw 'stepper (values 'continue t))))
  485. )            )
  486. #-ATARI
  487. (defconstant commands4
  488.              (list
  489.                #+DEUTSCH "
  490. Step     = Step into form: diese Form im Einzelschrittmodus ausführen
  491. Next     = Step over form: diese Form auf einmal ausführen
  492. Over     = Step over this level: bis zum Aufrufer auf einmal ausführen
  493. Continue = Einzelschrittmodus abschalten, Rest ausführen
  494. Step-until, Next-until, Over-until, Continue-until:
  495.            dito, jedoch mit Angabe einer Abbruchbedingung"
  496.                #+ENGLISH "
  497. Step     = step into form: evaluate this form in single step mode
  498. Next     = step over form: evaluate this form at once
  499. Over     = step over this level: evaluate at once up to the next return
  500. Continue = switch off single step mode, continue evaluation
  501. Step-until, Next-until, Over-until, Continue-until:
  502.            same as above, specify a condition when to stop"
  503.                (cons "Step"     #'(lambda () (throw 'stepper 'into)))
  504.                (cons "Next"     #'(lambda () (throw 'stepper 'over)))
  505.                (cons "Over"     #'(lambda () (throw 'stepper 'over-this-level)))
  506.                (cons "Continue" #'(lambda () (throw 'stepper 'continue)))
  507.                (cons "Step-until"     #'(lambda () (throw 'stepper (values 'into t))))
  508.                (cons "Next-until"     #'(lambda () (throw 'stepper (values 'over t))))
  509.                (cons "Over-until"     #'(lambda () (throw 'stepper (values 'over-this-level t))))
  510.                (cons "Continue-until" #'(lambda () (throw 'stepper (values 'continue t))))
  511. )            )
  512.  
  513. (defun step-values (values)
  514.   (let ((*standard-output* *debug-io*))
  515.     (terpri #|*debug-io*|#)
  516.     (write-string #+DEUTSCH "Step "
  517.                   #+ENGLISH "step "
  518.                   #|*debug-io*|#
  519.     )
  520.     (write *step-level* #|:stream *debug-io*|#)
  521.     (write-string " ==> " #|*debug-io*|#)
  522.     (case (length values)
  523.       (0 (write-string #+DEUTSCH "Keine Werte"
  524.                        #+ENGLISH "no values"
  525.                        #|*debug-io*|#
  526.       )  )
  527.       (1 (write-string #+DEUTSCH "Wert: "
  528.                        #+ENGLISH "value: "
  529.                        #|*debug-io*|#
  530.          )
  531.          (write (car values) #|:stream *debug-io*|#)
  532.       )
  533.       (t (write (length values) #|:stream *debug-io*|#)
  534.          (write-string #+DEUTSCH " Werte: "
  535.                        #+ENGLISH " values: "
  536.                        #|*debug-io*|#
  537.          )
  538.          (do ((L values))
  539.              ((endp L))
  540.            (write (pop L) #|:stream *debug-io*|#)
  541.            (unless (endp L) (write-string ", " #|*debug-io*|#))
  542.       )  )
  543.   ) )
  544.   (values-list values)
  545. )
  546.  
  547. (defun step-hook-fn (form &optional (env *toplevel-environment*))
  548.   (let ((*step-level* (1+ *step-level*)))
  549.     (when (>= *step-level* *step-quit*) ; Solange *step-level* >= *step-quit*
  550.       (if (and *step-watch* (funcall *step-watch*)) ; und kein Breakpoint,
  551.         (setq *step-quit* most-positive-fixnum)
  552.         (return-from step-hook-fn ; ist der Stepper passiv
  553.           (evalhook form nil nil env) ; (d.h. er evaluiert die Form einfach)
  554.     ) ) )
  555.     (tagbody
  556.       (let* ((stream (make-synonym-stream '*debug-io*))
  557.              (*standard-input* stream)
  558.              (*standard-output* stream)
  559.              (prompt (with-output-to-string (s)
  560.                        (write-string "Step " s)
  561.                        (write *step-level* :stream s)
  562.                        (write-string "> " s)
  563.              )       )
  564.              (*frame-limit1* (frame-limit1 11))
  565.              (*frame-limit2* (frame-limit2))
  566.              (*debug-mode* 4)
  567.              (*debug-frame* (frame-down-1 (frame-up-1 *frame-limit1* *debug-mode*) *debug-mode*))
  568.             )
  569.         (fresh-line #|*debug-io*|#)
  570.         (write-string #+DEUTSCH "Step "
  571.                       #+ENGLISH "step "
  572.                       #|*debug-io*|#
  573.         )
  574.         (write *step-level* #|:stream *debug-io*|#)
  575.         (write-string " --> " #|*debug-io*|#)
  576.         (write form #|:stream *debug-io*|# :length 4 :level 3)
  577.         (loop
  578.           (multiple-value-bind (what watchp)
  579.             (catch 'stepper ; die (throw 'stepper ...) abfangen und analysieren
  580.               (driver ; Driver-Frame aufbauen und folgende Funktion endlos ausführen:
  581.                 #'(lambda ()
  582.                     (case
  583.                         (catch 'debug ; die (throw 'debug ...) abfangen und analysieren
  584.                           (same-env-as *debug-frame* ; bei *debug-frame* gültiges Environment aufbauen
  585.                             #'(lambda ()
  586.                                 (if ; Eingabezeile verlangen
  587.                                     (read-eval-print prompt
  588.                                       (nconc (copy-list commands1)
  589.                                              (when (eval-frame-p *debug-frame*) (copy-list commands2))
  590.                                              (copy-list commands4)
  591.                                     ) )
  592.                                   ; T -> #<EOF>
  593.                                   (go continue)
  594.                                   ; NIL -> Form bereits ausgewertet und ausgegeben
  595.                                   #|(throw 'debug 'continue)|#
  596.                         ) )   ) )
  597.                       (unwind (go unwind))
  598.                       (t ) ; alles andere, insbesondere continue
  599.             ) )   ) )
  600.             (when watchp
  601.               (let ((form (read-form #+DEUTSCH "Abbruchbedingung: "
  602.                                      #+ENGLISH "condition when to stop: "
  603.                    ))     )
  604.                 (setq *step-watch* ; Funktion, die 'form' bei *debug-frame* auswertet
  605.                   (eval-at *debug-frame* `(function (lambda () ,form)))
  606.             ) ) )
  607.             (case what
  608.               (into (go into))
  609.               (over (go over))
  610.               (over-this-level (go over-this-level))
  611.               (continue (go continue))
  612.             )
  613.       ) ) )
  614.       unwind
  615.         (unwind-to-driver)
  616.       into
  617.         (return-from step-hook-fn
  618.           (step-values
  619.             (multiple-value-list (evalhook form #'step-hook-fn nil env))
  620.         ) )
  621.       over-this-level
  622.         (setq *step-quit* *step-level*) ; Stepper in Schlafzustand schalten
  623.       over
  624.         (return-from step-hook-fn
  625.           (step-values
  626.             (multiple-value-list (evalhook form nil nil env))
  627.         ) )
  628.       continue
  629.         (setq *step-quit* 0)
  630.         (go over)
  631. ) ) )
  632.  
  633. ;-------------------------------------------------------------------------------
  634. ;;                                  Errors
  635.  
  636. ; *ERROR-HANDLER* sollte NIL oder eine Funktion sein, die übergeben bekommt:
  637. ; - NIL (bei ERROR) bzw. continue-format-string (bei CERROR),
  638. ; - error-format-string,
  639. ; - Argumente dazu,
  640. ; und die nur zurückkehren sollte, falls das erstere /=NIL ist.
  641. (defvar *error-handler* nil)
  642.  
  643. ; (CERROR continue-format-string error-format-string {arg}*), CLTL S. 430
  644. (defun cerror (continue-format-string error-format-string &rest args)
  645.   (if *error-handler*
  646.     (apply *error-handler*
  647.            (or continue-format-string t) error-format-string args
  648.     )
  649.     (progn
  650.       (terpri *error-output*)
  651.       (write-string "** - Continuable Error" *error-output*)
  652.       (terpri *error-output*)
  653.       (apply #'format *error-output* error-format-string args)
  654.       (terpri *error-output*)
  655.       (if (interactive-stream-p *debug-io*)
  656.         (progn
  657.           #+ATARI (write-string #+DEUTSCH "Wenn Sie (mit F10) fortfahren: "
  658.                                 #+ENGLISH "If you continue (by pressing F10): "
  659.                                 *error-output*
  660.                   )
  661.           #-ATARI (write-string #+DEUTSCH "Wenn Sie (mit Continue) fortfahren: "
  662.                                 #+ENGLISH "If you continue (by typing 'continue'): "
  663.                                 *error-output*
  664.                   )
  665.           (apply #'format *error-output* continue-format-string args)
  666.           (funcall *break-driver* t)
  667.         )
  668.         (apply #'format *error-output* continue-format-string args)
  669.   ) ) )
  670.   nil
  671. )
  672.  
  673. (defvar *break-on-warnings* nil)
  674. ; (WARN format-string {arg}*), CLTL S. 432
  675. (defun warn (format-string &rest args)
  676.   (terpri *error-output*)
  677.   (write-string #+DEUTSCH "WARNUNG:"
  678.                 #+ENGLISH "WARNING:"
  679.                 *error-output*
  680.   )
  681.   (terpri *error-output*)
  682.   (apply #'format *error-output* format-string args)
  683.   (when *break-on-warnings* (funcall *break-driver* t))
  684.   nil
  685. )
  686.  
  687. ; (BREAK [format-string {arg}*]), CLTL S. 432
  688. (defun break (&optional (format-string "*** - Break") &rest args)
  689.   (terpri *error-output*)
  690.   (apply #'format *error-output* format-string args)
  691.   (funcall *break-driver* t)
  692.   nil
  693. )
  694.  
  695. ;-------------------------------------------------------------------------------
  696. ;;                            Querying the user
  697.  
  698. ; (Y-OR-N-P [format-string {arg}*]), CLTL S. 407
  699. (defun y-or-n-p (&optional format-string &rest args)
  700.   (when format-string
  701.     (fresh-line *query-io*)
  702.     (apply #'format *query-io* format-string args)
  703.     (write-string #+DEUTSCH " (j/n) "
  704.                   #+ENGLISH " (y/n) "
  705.                   *query-io*
  706.   ) )
  707.   (loop
  708.     (let ((line (string-left-trim " " (read-line *query-io*))))
  709.       (when (plusp (length line))
  710.         (case (char-upcase (char line 0))
  711.           (#\N (return nil))
  712.           ((#\J #\Y) (return t))
  713.     ) ) )
  714.     (terpri *query-io*)
  715.     (write-string #+DEUTSCH "Bitte mit j oder n antworten: "
  716.                   #+ENGLISH "Please answer with y or n : "
  717.                   *query-io*
  718. ) ) )
  719.  
  720. ; (YES-OR-NO-P [format-string {arg}*]), CLTL S. 408
  721. (defun yes-or-no-p (&optional format-string &rest args)
  722.   (when format-string
  723.     (fresh-line *query-io*)
  724.     (apply #'format *query-io* format-string args)
  725.     (write-string #+DEUTSCH " (ja/nein) "
  726.                   #+ENGLISH " (yes/no) "
  727.                   *query-io*
  728.   ) )
  729.   (loop
  730.     (clear-input *query-io*)
  731.     (let* ((line (string-trim " " (read-line *query-io*)))
  732.            (h (assoc line '(("ja" . t) ("nein" . nil) ("yes" . t) ("no" . nil))
  733.                           :test #'string-equal
  734.           ))  )
  735.       (when h (return (cdr h)))
  736.     )
  737.     (terpri *query-io*)
  738.     (write-string #+DEUTSCH "Bitte mit ja oder nein antworten: "
  739.                   #+ENGLISH "Please answer with yes or no : "
  740.                   *query-io*
  741. ) ) )
  742.  
  743. #-AMIGA
  744. (progn
  745.   (defvar *keyboard-input*)
  746.   (defmacro with-keyboard (&body body)
  747.     #+(or ATARI DOS OS/2) ; *keyboard-input* existiert schon
  748.       `(LET () (PROGN ,@body))
  749.     #+(or UNIX VMS)
  750.       `(UNWIND-PROTECT
  751.          (PROGN
  752.            (SYS::TERMINAL-RAW *TERMINAL-IO* T)
  753.            ,@body
  754.          )
  755.          (SYS::TERMINAL-RAW *TERMINAL-IO* NIL)
  756.        )
  757.   )
  758. )
  759.  
  760.